home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / bbsutil / dlx70bbs.zip / DLX70SRC.ZIP / FUNS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-02-14  |  40KB  |  1,006 lines
  1. {$debug-}
  2. {$line-}
  3.  
  4. {$include: 'types.int'}
  5. {$include: 'globals.int'}
  6. {$include: 'load.int'}
  7. {$include: 'utils.int'}
  8. {$include: 'database.int'}
  9. {$include: 'funs.int'}
  10.  
  11. IMPLEMENTATION OF funs;
  12.  
  13. USES types,globals,load,utils,database;
  14.  
  15. {DLX Bulletin Board System V7.0
  16.  
  17.  FREEWARE NOTICE
  18.  
  19.  DLX V7.0 is placed in the public domain by its author, Richard Gillmann.
  20.  Anyone who wishes to may run the program, copy it, or modify it for
  21.  any purpose, including commercial gain.}
  22.  
  23. {***INTERFACE TO THE COM_PAX2 ASYNCHRONOUS COMMUNICATIONS PACKAGE***}
  24. {$include: 'com_pax2.int'}
  25.  
  26. {***Interface to the PASASM assembler utilities package***}
  27. {$include: 'pasasm.int'}
  28. {$include: 'newasm.int'}
  29.  
  30. {***Interface to MS Pascal library***}
  31. function freect(size:word) : word; EXTERN;
  32.  
  33. var
  34.   cancelled [EXTERN] : boolean;
  35.   bs_local [EXTERN] : byte;
  36.  
  37. procedure secs2time(secs : integer4; var tt : lstring);
  38. var
  39.   s,m : integer4;
  40. begin
  41.   copylst(ss[19],tt); {00:00:00}
  42.   if secs>0 then
  43.     [s:=secs mod 60;
  44.      secs:=secs div 60;
  45.      m:=secs mod 60;
  46.      secs:=secs div 60;
  47.      if secs<100 then
  48.        [tt[1]:=chr(ord('0')+ord(secs div 10));
  49.         tt[2]:=chr(ord('0')+ord(secs mod 10));
  50.         tt[4]:=chr(ord('0')+ord(m div 10));
  51.         tt[5]:=chr(ord('0')+ord(m mod 10));
  52.         tt[7]:=chr(ord('0')+ord(s div 10));
  53.         tt[8]:=chr(ord('0')+ord(s mod 10))]
  54.      else
  55.        [tt[1]:='9'; tt[2]:='9';
  56.         tt[4]:='5'; tt[5]:='9';
  57.         tt[7]:='5'; tt[8]:='9']];
  58. end {secs2time};
  59.  
  60. procedure make12(var tt : lstring);
  61. var
  62.   h : integer;
  63. begin
  64.   if tt.len=8
  65.     then tt.len:=5
  66.     else return;
  67.   h:=10*(ord(tt[1])-ord('0')) + (ord(tt[2])-ord('0'));
  68.   if h=0 then
  69.     [tt[1]:='1'; tt[2]:='2';
  70.      concat(tt,' '); concat(tt,ss[24])] {AM}
  71.   else if h<12 then
  72.     [concat(tt,' '); concat(tt,ss[24])] {AM}
  73.   else if h=12 then
  74.     [concat(tt,' '); concat(tt,ss[25])] {PM}
  75.   else
  76.     [h:=h-12;
  77.      tt[1]:=chr(ord('0')+ord(h div 10));
  78.      tt[2]:=chr(ord('0')+ord(h mod 10));
  79.      concat(tt,' '); concat(tt,ss[25])]; {PM}
  80. end {make12};
  81.  
  82. function match_pc(const toi : member_record) : integer;
  83. var
  84.   pc,m,f,temp,i,j,wt1,wt2 : integer;
  85. begin
  86. {not relevant until logged in}
  87.   if not q[wx].logged_in then
  88.     [match_pc:=0; return];
  89. {match perfectly to oneself}
  90.   if ivalue(toi.userid) = q[wx].userid then
  91.     [match_pc:=100; return];
  92. {gender & orientation}
  93.   if q[wx].my.pref[1]=mn[3][1] {S} then
  94.     [if toi.pref[1]=mn[3][1] {S} then
  95.        [if q[wx].my.gender[1]=toi.gender[1]
  96.           then pc:=0 else pc:=100]
  97.      else if toi.pref[1]=mn[3][3] {G} then
  98.        pc:=0
  99.      else {B}
  100.        [if q[wx].my.gender[1]=toi.gender[1]
  101.           then pc:=0 else pc:=70]]
  102.   else if q[wx].my.pref[1]=mn[3][3] {G} then
  103.     [if toi.pref[1]=mn[3][1] {S} then
  104.        pc:=0
  105.      else if toi.pref[1]=mn[3][3] {G} then
  106.        [if q[wx].my.gender[1]=toi.gender[1]
  107.           then pc:=100 else pc:=0]
  108.      else {B}
  109.        [if q[wx].my.gender[1]=toi.gender[1]
  110.           then pc:=90 else pc:=0]]
  111.   else {b}
  112.     [if toi.pref[1]=mn[3][1] {S} then
  113.        [if q[wx].my.gender[1]=toi.gender[1]
  114.           then pc:=0 else pc:=70]
  115.      else if toi.pref[1]=mn[3][3] {G} then
  116.        [if q[wx].my.gender[1]=toi.gender[1]
  117.           then pc:=90 else pc:=0]
  118.      else {B}
  119.        pc:=100];
  120.   if pc=0 then [match_pc:=0; return];
  121. {propinquity}
  122.   if q[wx].my.state=toi.state then
  123.     [if q[wx].my.city[1]<>toi.city[1] then pc:=pc-10]
  124.   else
  125.     pc:=pc-20;
  126. {age};
  127.   m:=ivalue(q[wx].my.age); f:=ivalue(toi.age);
  128.   if q[wx].my.gender[1]=mn[2][2] {F} and then
  129.      toi.gender[1]=mn[2][1] {M} then
  130.     [temp:=m; m:=f; f:=temp];
  131.   if m<60 and then q[wx].my.gender[1]<>toi.gender[1]
  132.     then pc:=pc-5*abs(((3*m+14) div 4)-f)
  133.     else pc:=pc-5*abs(m-f);
  134. {height}
  135.   if q[wx].my.gender[1]=mn[2][1] {M}
  136.     then m:=hvalue(q[wx].my.height)
  137.     else
  138.       [if metric
  139.          then m:=hvalue(q[wx].my.height)+13
  140.      else m:=hvalue(q[wx].my.height)+5];
  141.   if toi.gender[1]=mn[2][1] {M}
  142.     then f:=hvalue(toi.height)
  143.     else [if metric
  144.              then f:=hvalue(toi.height)+13
  145.         else f:=hvalue(toi.height)+5];
  146.   if metric
  147.     then pc:=pc-2*abs(m-f)
  148.     else pc:=pc-4*abs(m-f);
  149. {weight}
  150.   wt1:=ivalue(q[wx].my.weight);
  151.   wt2:=ivalue(toi.weight);
  152.   if metric then {convert kg to lb}
  153.     [wt1:=(wt1*22) div 10;
  154.      wt2:=(wt2*22) div 10];
  155.   if wt1<100 then wt1:=250; {lying about weight}
  156.   if wt2<100 then wt2:=250;
  157.   temp:=(wt1+wt2-300) div 3; {lb}
  158.   if wt1>200 and then wt2>200 then {both fat}
  159.     temp:=temp div 2;
  160.   if temp>0 then pc:=pc-temp;
  161. {weight difference}
  162.   if q[wx].my.gender[1]=mn[2][1] {M} and then
  163.      toi.gender[1]=mn[2][2] {F} and then
  164.      ivalue(q[wx].my.weight)<ivalue(toi.weight) then
  165.     temp:=ivalue(toi.weight)-ivalue(q[wx].my.weight)
  166.   else if q[wx].my.gender[1]=mn[2][2] {F} and then
  167.      toi.gender[1]=mn[2][1] {M} and then
  168.      ivalue(q[wx].my.weight)>ivalue(toi.weight) then
  169.     temp:=ivalue(q[wx].my.weight)-ivalue(toi.weight)
  170.   else temp:=0;
  171.   if metric
  172.     then pc:=pc-2*temp
  173.     else pc:=pc-temp;
  174. {multiple choice questions}
  175.   for i:=1 to 2 do {based on just the first two questionnaires}
  176.     for j:=1 to number_of_answers do
  177.       if q[wx].my.mult_answer[i][j]<>' ' and then
  178.          q[wx].my.mult_answer[i][j]=toi.mult_answer[i][j] then
  179.         pc:=pc+1;
  180.   pc:=pc-5; {allow for random hits}
  181. {limit range}
  182.   if pc<11 then
  183.     match_pc:=11
  184.   else if pc>100 then
  185.     match_pc:=100
  186.   else
  187.     match_pc:=pc;
  188. end {match_pc};
  189.  
  190. type
  191.  jtype = (left,right,vari,vari_tr);
  192.  wtype = (my,your,xmy,xyour,usrlog);
  193.  ttype = (mins,hms);
  194.  
  195. var
  196.   arg : -1..99;
  197.   just : jtype;
  198.   whose : wtype;
  199.   plural : boolean;
  200.   time_f : ttype;
  201.   time_f2 : integer;
  202.   min_mem : integer4;
  203.   jlen : word;
  204.  
  205. value
  206.   min_mem := 1048576;
  207.  
  208. procedure init_fx;
  209. begin
  210.   arg:=-1;
  211.   just:=vari;
  212.   whose:=my;
  213.   plural:=true;
  214.   time_f:=mins;
  215.   time_f2:=24;
  216.   jlen:=0;
  217. end {init_fx};
  218.  
  219. function funx{col : integer; c1,c2 : char; var s : lstring} {boolean};
  220. var
  221.   cap1,cap2,ok,special : boolean;
  222.   mrp : adr of member_record;
  223.   qrp : adr of q_record;
  224.   wrp : ads of window;
  225.   i,j,k : integer;
  226.   i4,j4 : integer4;
  227.   qst : questions;
  228.   p : para;
  229.   nl : word;
  230.   str : lstring(screen_cols+40);
  231.   mh : mailhead;
  232.   o2 : char;
  233.   kill : boolean;
  234. label
  235.   skipcase;
  236.  
  237.   procedure expand_macro(p : para);
  238.   var
  239.     xarg : -1..99;
  240.     xjust : jtype;
  241.     xwhose : wtype;
  242.     xplural : boolean;
  243.     xtime_f : ttype;
  244.     xtime_f2 : integer;
  245.     xmin_mem : integer4;
  246.     xjlen : word;
  247.   begin
  248. {save state}
  249.     xarg:=arg; xjust:=just; xwhose:=whose; xplural:=plural;
  250.     xtime_f:=time_f; xtime_f2:=time_f2; xmin_mem:=min_mem; xjlen:=jlen;
  251.     macro_depth := macro_depth + 1;
  252. {expand}
  253.     arg:=-1; just:=vari; jlen:=0;
  254.     copylst(p^.msg,str); delete(str,1,4);
  255.     eval(substitute(str)); stripx(str,s);
  256. {restore state}
  257.     macro_depth := macro_depth - 1;
  258.     arg:=xarg; just:=xjust; whose:=xwhose; plural:=xplural;
  259.     time_f:=xtime_f; time_f2:=xtime_f2; min_mem:=xmin_mem; jlen:=xjlen;
  260.   end {expand_macro};
  261.  
  262. begin
  263.   kill:=false;
  264.   o2:=c2;
  265.   s.len:=0;
  266.   if c1>='A' and then c1<='Z'
  267.     then cap1:=true
  268.     else cap1:=false;
  269.   if c2>='A' and then c2<='Z'
  270.     then cap2:=true
  271.     else cap2:=false;
  272.   c1:=uc(c1); c2:=uc(c2);
  273.   wrp:=ads w^[wx]; qrp:=adr q[wx]; mrp:=adr q[wx].my;
  274.   case whose of
  275.     my : ;
  276.     your : [mrp:=adr q[wx].your;
  277.             i:=on_line(ivalue(mrp^.userid));
  278.             if i>=0 then mrp:=adr q[i].my];
  279.     xmy : if q[wx].index>=0 and then q[wx].index<=number_of_lines and then
  280.              w^[q[wx].index].active and then
  281.              w^[q[wx].index].state=going and then
  282.              q[q[wx].index].logged_in
  283.             then [mrp:=adr q[q[wx].index].my; qrp:= adr q[q[wx].index];
  284.                   wrp:=ads w^[q[wx].index]]
  285.             else kill:=true;
  286.     xyour : if q[wx].index>=0 and then q[wx].index<=number_of_lines and then
  287.                w^[q[wx].index].active and then
  288.                w^[q[wx].index].state=going and then
  289.                q[q[wx].index].logged_in
  290.               then [mr